home *** CD-ROM | disk | FTP | other *** search
/ Especial Multimedia / Especial Multimedia.iso / Multimed / Prg / FADE2.ZIP / FADE.BAS < prev    next >
BASIC Source File  |  1997-09-14  |  5KB  |  114 lines
  1. Option Explicit
  2.  
  3. '  Data type used by FillRect
  4. Type RECT
  5.     Left As Integer
  6.     Top As Integer
  7.     Right As Integer
  8.     Bottom As Integer
  9. End Type
  10.  
  11. Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer
  12. Declare Function FillRect Lib "User" (ByVal hDC As Integer, lpRect As RECT, ByVal hBrush As Integer) As Integer
  13. Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
  14. Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
  15.  
  16. ' Standard Win constants
  17. Const BITSPIXEL = 12    '  Number of bits per pixel
  18. Const PLANES = 14       '  Number of planes
  19.  
  20. Sub FadeForm (frmIn As Form, intGradientType As Integer)
  21.     ' intGradientType = 0 produces diagonal gradient
  22.     ' intGradientType = 1 produces vertical gradient
  23.     ' intGradientType = 2 produces horizontal gradient
  24.     ' any other value     produces solid medium-blue background
  25.     
  26.  
  27.     Static lngColorBits As Long, intRgnCnt As Integer
  28.     
  29.     Dim intNbrPlanes As Integer, intBitsPixel As Integer
  30.     Dim intHeight As Integer, intWidth As Integer, intBlueLevel As Integer
  31.     Dim intIntervalY As Integer, intIntervalX As Integer
  32.     Dim intTemp As Integer, intRetVal As Integer, intColorInterval As Integer
  33.     Dim FillArea As RECT, hBrush As Integer
  34.  
  35.     ' This init code will be performed only on the first pass through this routine.
  36.     If lngColorBits = 0 Then
  37.         ' determine number of color bits supported.
  38.         intBitsPixel = GetDeviceCaps(frmIn.hDC, BITSPIXEL)
  39.         intNbrPlanes = GetDeviceCaps(frmIn.hDC, PLANES)
  40.         lngColorBits = intBitsPixel * intNbrPlanes
  41.         ' Calculate the number of regions that the screen will be divided into.
  42.         ' This is optimized for the current display's color depth.  Why waste
  43.         ' time rendering 256 shades if you can only discern 32 or 64 of them?
  44.         If lngColorBits = 24 Then       ' 16M colors:  8 bits for blue
  45.             intRgnCnt = 256
  46.         ElseIf lngColorBits = 16 Then   ' 64K colors:  5 bits for blue
  47.             intRgnCnt = 32
  48.         ElseIf lngColorBits = 15 Then   ' 32K colors:  5 bits for blue
  49.             intRgnCnt = 32
  50.         ElseIf lngColorBits = 8 Then    ' 256 colors:  64 dithered blues
  51.             intRgnCnt = 64
  52.         ElseIf lngColorBits = 4 Then    ' 16 colors :  64 dithered blues
  53.             intRgnCnt = 64
  54.         Else
  55.             lngColorBits = 4
  56.             intRgnCnt = 64              ' 16 colors assumed: 64 dithered blues
  57.         End If
  58.     End If
  59.     
  60.     If intGradientType < 0 Or intGradientType > 2 Then
  61.         frmIn.BackColor = &H7F0000 ' med blue
  62.         Exit Sub
  63.     End If
  64.             
  65.     intTemp = frmIn.ScaleMode
  66.     frmIn.ScaleMode = 3  'Pixel
  67.     intHeight = frmIn.ScaleHeight
  68.     intWidth = frmIn.ScaleWidth
  69.     frmIn.ScaleMode = intTemp
  70.     
  71.     intColorInterval = 256 \ intRgnCnt          ' color diff between regions
  72.     intIntervalY = intHeight \ intRgnCnt        ' # vert pixels per region
  73.     intIntervalX = intWidth \ intRgnCnt         ' # horz pixels per region
  74.     
  75.     ' fill the client area from bottom/right to top/left except for top/left region
  76.     FillArea.Left = 0
  77.     FillArea.Top = 0
  78.     FillArea.Right = intWidth
  79.     FillArea.Bottom = intHeight
  80.     intBlueLevel = 0
  81.     For intTemp = 0 To intRgnCnt - 2
  82.         hBrush = CreateSolidBrush(RGB(0, 0, intBlueLevel))
  83.         If intGradientType = 0 Then         ' diagonal gradient
  84.             FillArea.Top = FillArea.Bottom - intIntervalY
  85.             FillArea.Left = 0
  86.             intRetVal = FillRect(frmIn.hDC, FillArea, hBrush)
  87.             FillArea.Top = 0
  88.             FillArea.Left = FillArea.Right - intIntervalX
  89.             intRetVal = FillRect(frmIn.hDC, FillArea, hBrush)
  90.             FillArea.Bottom = FillArea.Bottom - intIntervalY
  91.             FillArea.Right = FillArea.Right - intIntervalX
  92.         ElseIf intGradientType = 1 Then     ' vertical gradient
  93.             FillArea.Top = FillArea.Bottom - intIntervalY
  94.             intRetVal = FillRect(frmIn.hDC, FillArea, hBrush)
  95.             FillArea.Bottom = FillArea.Bottom - intIntervalY
  96.         Else                                ' horizontal gradient implied
  97.             FillArea.Left = FillArea.Right - intIntervalX
  98.             intRetVal = FillRect(frmIn.hDC, FillArea, hBrush)
  99.             FillArea.Right = FillArea.Right - intIntervalX
  100.         End If
  101.         intRetVal = DeleteObject(hBrush)
  102.         intBlueLevel = intBlueLevel + intColorInterval
  103.     Next
  104.  
  105.     ' Fill the remaining top/left of the client area with solid blue
  106.     FillArea.Top = 0
  107.     FillArea.Left = 0
  108.     hBrush = CreateSolidBrush(RGB(0, 0, 255))
  109.     intRetVal = FillRect(frmIn.hDC, FillArea, hBrush)
  110.     intRetVal = DeleteObject(hBrush)
  111.     
  112. End Sub
  113.  
  114.